module Syntax where

import Data.List (find)
import Maybe

type HsExps = [HsExp]

type HsCondExp = (HsExps, HsExp) -- conditions, expression to execute
type HsMethodName = String
type HsMethodArgs = [HsMethodArg]
type HsClassName = String
type HsInterfaceName = String
type HsVarType = HsClassName

data HsExp = HsInt Int
           | HsVar String
           | HsString String
           | HsPattern String
           | HsBrace HsExp
           | HsUnaryOp HsUnaryOpKind HsExp
           | HsBinaryOp HsBinaryOpKind HsExp HsExp
           | HsCall HsExp HsExps (Maybe HsCallBlock)
           | HsSequence HsSequenceKind HsExps
           | HsAlt HsAltKind [HsCondExp] (Maybe HsExp)
           | HsLoop HsLoopKind HsExp
           | HsReturn (Maybe HsExp)
           | HsArray HsExps
           | HsHash [HsHashKey]
           | HsArrayIndex HsExp HsExp
           | HsListComprehension HsExp [(HsExp, HsExp)] (Maybe HsExp)
           | HsBlock HsBlockKind HsExp
           | HsRequire [String]
           | HsWith HsExp HsExp
           | HsTypedExp HsVarType HsExps
           deriving Show

data HsBlockKind = HsMethod HsMethodOption HsMethodKind HsMethodName (Maybe HsMethodArgs)
                 | HsClass HsClassName (Maybe HsMethodArgs) (Maybe HsClassName) [HsInterfaceName]
                 | HsModule HsClassName
                 | HsInterface HsClassName
                 | HsStruct HsClassName HsMethodArgs
                 deriving Show

data HsAltKind = HsIf
               | HsUnless
               | HsCase (Maybe HsExp)
               deriving Show

data HsMethodOption = HsOptNone
                    | HsOptStatic
                    | HsOptOverride
                    | HsOptAbstract
                    deriving Show

data HsMethodArg = HsMethodArg String (Maybe HsExp) (Maybe HsVarType)
                 deriving Show

data HsLoopKind = HsWhile HsExp
                | HsUntil HsExp
                | HsLoopInfinite
                | HsFor HsExp HsExp
                deriving Show

data HsCallBlock = HsCallBlock [String] HsExp
                 deriving Show

data HsSequenceKind = HsSeqSingleLine
                    | HsSeqMultiLine
                    deriving Show

data HsMethodKind = HsMethodFunction (Maybe HsVarType)
                  | HsMethodProcedure
                  | HsMethodDef
                  deriving Show

data HsHashKey = HsHashKey HsExp HsExp
               deriving Show

data HsUnaryOpKind = HsOpWordNot | HsOpNot | HsOpBitNot | HsOpNegate
                   | HsPreIncrement | HsPostIncrement | HsPreDecrement | HsPostDecrement
                   | HsOpRangeIncludeLeft
                   deriving Show

data HsBinaryOpKind = HsOpWordIf | HsOpWordUnless | HsOpWordWhile | HsOpWordUntil |
                      HsOpWordOr | HsOpWordAnd |
                      HsOpWordDefined |
                      HsOpSet | HsOpSetMod | HsOpSetPat | HsOpSetDiv | HsOpSetSub | HsOpSetAdd | HsOpSetMul | HsOpSetPow |
                      HsOpSetBitOr | HsOpSetBitAnd | HsOpSetOr | HsOpSetAnd | HsOpSetShiftLeft | HsOpSetShiftRight |
                      HsOpRangeInclude | HsOpRangeExclude |
                      HsOpOr | HsOpAnd | 
                      HsOpComp | HsOpEq | HsOpNotEq | HsOpInRange | HsOpEqPat | HsOpNotEqPat |
                      HsOpLessEq | HsOpLess | HsOpGreat | HsOpGreatEq |
                      HsOpBitOr | HsOpBitXOr | HsOpBitAnd |
                      HsOpShiftLeft | HsOpShiftRight |
                      HsOpAdd | HsOpSub | 
                      HsOpMul | HsOpDiv | HsOpMod |
                      HsOpPow |
                      HsOpMember | HsOpHashMember
                      deriving Show

{-
 - Costruttori
 -}

hsEmpty = hsMultiLineSequence []

hsCondsExp conds e = (conds, e)
hsCondExp cond = hsCondsExp [cond]

hsBrace = HsBrace
hsVar = HsVar
hsMethodName = HsVar
hsConst = hsVar
hsInt = HsInt
hsAttr = hsVar . ('@':)
hsStatic = hsVar . ("@@"++)
hsGlobal = hsVar . ('$':)
hsSymbol = hsVar . (':':)
hsArray = HsArray
hsArrayIndex = HsArrayIndex

hsSequence k [e] = e
hsSequence k es  = HsSequence k es
hsLineSequence = hsSequence HsSeqSingleLine
hsMultiLineSequence = hsSequence HsSeqMultiLine

hsRequire name = HsRequire [name]

hsCall = HsCall
hsCallName name = hsCall $ hsMethodName name
hsCallMethod :: HsExp -> String -> HsExps -> (Maybe HsCallBlock) -> HsExp
hsCallMethod obj method = hsCall (obj `hsMember` hsMethodName method)

hsAlt = HsAlt
hsIf = hsAlt HsIf
hsIfOnly cond body = hsIf [hsCondExp cond body] Nothing
hsCase item = hsAlt $ HsCase item
hsUnaryOp k x = HsUnaryOp k (hsSafe x)
hsBinaryOp k x y = HsBinaryOp k (hsSafe x) (hsSafe y)
hsLoop = HsLoop
hsWhile cond = hsLoop $ HsWhile cond
hsUntil cond = hsLoop $ HsUntil cond
hsFor item range = hsLoop $ HsFor item range
hsUnless = HsUnless
hsReturnValue = HsReturn . Just . hsSafe

hsBlockEmpty header = HsBlock header hsEmpty
hsClass name args super interfaces = HsBlock $ HsClass name args super interfaces
hsModule name = HsBlock $ HsModule name
hsMethod kind name args body = HsBlock (HsMethod HsOptNone kind name args) body
hsMethod' opt kind name args body = HsBlock (HsMethod opt' kind name args) body -- per il parser
  where
    opt' | hsIsEmpty body = HsOptAbstract
         | otherwise      = opt
hsProcedure = hsMethod HsMethodProcedure
hsFunction = hsMethod (HsMethodFunction Nothing)
hsDef = hsMethod HsMethodDef
hsStruct name = hsBlockEmpty . HsStruct name

hsMethodArg = HsMethodArg
hsMethodArgs = id

hsCallBlock = HsCallBlock

-- operatori unari
hsPreIncrement = hsUnaryOp HsPreIncrement
hsPreDecrement = hsUnaryOp HsPreDecrement

-- operatori binari
hsSet = hsBinaryOp HsOpSet
hsSetAdd = hsBinaryOp HsOpSetAdd
hsSetSub = hsBinaryOp HsOpSetSub
hsShiftLeft = hsBinaryOp HsOpShiftLeft
hsWordAnd = hsBinaryOp HsOpWordAnd
hsAnd = hsBinaryOp HsOpAnd
hsEqual = hsBinaryOp HsOpEq
hsOr = hsBinaryOp HsOpOr
hsRangeExclude = hsBinaryOp HsOpRangeExclude
hsMember = hsBinaryOp HsOpMember

{-
 - Query
 -}

hsApplyOr :: HsExps -> HsExp
hsApplyOr es = foldl1 hsOr $ map hsBrace es

hsArgName :: HsMethodArg -> String
hsArgName (HsMethodArg name _ _) = name

hsIsEmpty (HsSequence _ []) = True
hsIsEmpty _                 = False

hsConcat :: HsExp -> HsExp -> HsExp
hsConcat (HsSequence k xs) (HsSequence _ ys) = hsSequence k (xs ++ ys)
hsConcat x                 (HsSequence k xs) = hsSequence k (x:xs)
hsConcat (HsSequence k xs)  x                = hsSequence k (xs ++ [x])
hsConcat x                  y                = hsMultiLineSequence [x, y]

isRelationalOp :: HsBinaryOpKind -> Bool
isRelationalOp HsOpComp = True
isRelationalOp HsOpEq = True
isRelationalOp HsOpNotEq = True
isRelationalOp HsOpInRange = True
isRelationalOp HsOpEqPat = True
isRelationalOp HsOpNotEqPat = True
isRelationalOp HsOpLessEq = True
isRelationalOp HsOpLess = True
isRelationalOp HsOpGreat = True
isRelationalOp HsOpGreatEq = True
isRelationalOp _ = False

isHsRelationalOp :: HsExp -> Bool
isHsRelationalOp (HsBinaryOp op _ _) = isRelationalOp op
isHsRelationalOp _ = False

hsExistsMethod :: HsMethodName -> HsExp -> Bool
hsExistsMethod name e = 
  case hsGetMethod name e of
    Nothing   -> False
    otherwise -> True

hsGetMethod :: HsMethodName -> HsExp -> Maybe HsExp
hsGetMethod name (HsSequence _ es) = find (hsIsTheMethod name) es

hsBlockName :: HsExp -> String
hsBlockName (HsBlock (HsMethod _ _ name _) _) = name
hsBlockName _ = ""

hsIsMethod :: HsExp -> Bool
hsIsMethod (HsBlock (HsMethod _ _ _ _) _) = True
hsIsMethod _ = False

hsIsTheMethod :: HsMethodName -> HsExp -> Bool
hsIsTheMethod name e | hsIsMethod e && 
                       hsBlockName e == name = True
hsIsTheMethod _ _ = False

hsGetMethodArg :: String -> [HsMethodArg] -> Maybe HsMethodArg
hsGetMethodArg name = find ((name ==) . hsMethodArgName)

hsMethodArgName :: HsMethodArg -> String
hsMethodArgName (HsMethodArg name _ _) = name

hsIsSimple :: HsExp -> Bool
hsIsSimple e = case e of
  HsVar _    -> True
  HsInt _    -> True
  HsString _ -> True
  HsPattern _ -> True
  HsBrace _  -> True
  HsCall _ _ Nothing -> True
  HsArray _  -> True
  HsHash _   -> True
  otherwise  -> False

hsSafe :: HsExp -> HsExp
hsSafe e | hsIsSimple e = e
         | otherwise    = hsBrace e

hsIsReturnValue :: HsExp -> Bool
hsIsReturnValue (HsReturn (Just _)) = True
hsIsReturnValue _                   = False

hsVisitAll :: HsExp -> Bool
hsVisitAll _ = True

hsVisitTopLevel :: HsExp -> Bool
hsVisitTopLevel (HsSequence _ _) = True
hsVisitTopLevel _ = False

hsIsExecuted :: HsExp -> Bool
hsIsExecuted (HsBlock _ _) = False
hsIsExecuted _ = True

hsMap :: (HsExp -> HsExp) -> HsExp -> HsExp
hsMap f e = f $
  case e of
    HsBrace e -> HsBrace $ g e
    HsUnaryOp k x -> hsUnaryOp k $ g x
    HsBinaryOp k x y -> hsBinaryOp k (g x) (g y)
    HsCall e es block -> HsCall (g e) (mapExps es) (mapBlock block)
    HsSequence k es -> HsSequence k $ mapExps es
    HsAlt k conds el -> HsAlt k (mapConds conds) (mapMaybe el)
    HsLoop k e -> HsLoop k $ g e
    HsReturn (Just e) -> hsReturnValue $ g e
    HsArray es -> HsArray $ mapExps es
    HsArrayIndex array index -> HsArrayIndex (g array) (g index)
    HsListComprehension item fors sel -> HsListComprehension (g item) (mapPairs fors) (mapMaybe sel)
    HsBlock k e -> HsBlock k $ g e
    HsWith item e -> HsWith (g item) (g e)
    HsTypedExp t es -> HsTypedExp t (mapExps es)
    otherwise -> e
  where
    g = hsMap f
    mapExps = map g
    
    mapMaybe Nothing  = Nothing
    mapMaybe (Just e) = Just $ g e
    
    mapPair (x, y) = (g x, g y)
    mapPairs = map mapPair
    
    mapCond (xs, y) = (mapExps xs, f y)
    mapConds = map mapCond
    
    mapBlock Nothing = Nothing
    mapBlock (Just (HsCallBlock args e)) = Just $ HsCallBlock args $ g e

hsFind :: (HsExp -> Bool) -> (HsExp -> Bool) -> HsExp -> Maybe HsExp
hsFind visit p = listToMaybe . hsFilter visit p

hsFilter :: (HsExp -> Bool) -> (HsExp -> Bool) -> HsExp -> HsExps
hsFilter visit p e | p e       = [e]
                   | visit e   = aux e
                   | otherwise = []
  where
    aux (HsSequence k es) = hsFilters visit p es
    aux (HsLoop _ body) = hsFilter visit p body
    aux (HsBlock _ body) = hsFilter visit p body
    -- completare!
    aux _ = []

hsFilters :: (HsExp -> Bool) -> (HsExp -> Bool) -> HsExps -> HsExps
hsFilters visit p = concat . map (hsFilter visit p)